home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istpf / PFLIB1.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  31.4 KB  |  871 lines
  1.  
  2. C type PFPU = record
  3. C               NAME: integer; (* index into NAMTXT *)
  4. C               NARGS: integer;
  5. C               ARGS: ^(heap) HEAD (PFPUARG); (* 0 = nil *)
  6. C               COMMONS: ^(heap) HEAD (PFPUCU); (* 0 for ENTRY points *)
  7. C               PARENTS: ^(heap) HEAD (PARENT); (* ditto *)
  8. C               DESC: ^(heap) HEAD (PFPUDESC);  (* ditto *)
  9. C               DTYPE: integer;
  10. C               CHRLEN: integer;
  11. C               ACTUAL: ^PFPU         (* 0 except for ENTRY points *)
  12. C             end;
  13.  
  14. C type PFEX = record
  15. C               NAME: integer;
  16. C               DTYPE: integer;
  17. C               CHRLEN: integer;
  18. C               NARGS: integer;
  19. C               ARGS: ^(heap) HEAD(PFEXARG);
  20. C               INDARG: ^PFPUARG    (* only for indirect refs *)
  21. C             end;
  22.  
  23. C type PFPUARG = record
  24. C                   DTYPE: integer;
  25. C                   CHLEN: integer;
  26. C                   case STRUC of
  27. C                       var,array: (USAGE: (arg,read,update));
  28. C                       proc: (REF: integer (EXNODE index))
  29. C                       end;
  30. C                   STRUC: (var,array,proc);
  31. C                   SIZE: integer;
  32. C                   DESC: ^(heap) HEAD (PUARGDES);
  33. C                   PROCS: ^(heap) HEAD (PFPROC);
  34. C                   PRNTS: ^(heap) HEAD (LATPAR)
  35. C                end;
  36.  
  37. C type PFEXARG = record
  38. C                   DTYPE: integer;
  39. C                   ATYPE: integer;
  40. C                   PROCS: ^(heap) HEAD (PFPROC);
  41. C                   if (DTYPE=type_char) then
  42. C                       CHMIN,CHMAX: integer
  43. C                   end if
  44. C                 end;
  45.  
  46. C type PFPUDESC = record
  47. C                   NODE: integer (* +ve => index into PUNODE,
  48. C                                    -ve => -index into EXNODE *)
  49. C                 end;
  50. C
  51. C type PFPUCU = record
  52. C                   CBNUM: integer; (* index into CBDATA *)
  53. C                   USAGE: (readonly,update)
  54. C               end;
  55.  
  56. C type PUARGDES = record
  57. C                   TYPE: (direct,indirect);
  58. C                   ANUM: integer;  (* argument number passed out as *)
  59. C                   case TYPE of
  60. C                       direct: (NODE: integer); (* PUNODE/EXNODE index *)
  61. C                       indirect: (INUM: integer)   (* arg no. passed to *)
  62. C                       end
  63. C                 end;
  64.  
  65. C type PFPROC = record
  66. C                   NODE: integer;  (* PUNODE/EXNODE index of associated pu *)
  67. C                   ASSOC: integer; (* ditto of associating pu. *)
  68. C                   STMTNO: integer (* statement number of association *)
  69. C               end;
  70.  
  71. C
  72. C type PARENT = record (* routine parent *)
  73. C                   NODE: integer   (* PUNODE index of parent routine *)
  74. C               end;
  75. C
  76. C type APARENT = record (* argument parent *)
  77. C                   NODE: integer;  (* PUNODE index of parent routine *)
  78. C                   ANUM: integer   (* argument number passed down *)
  79. C                end;
  80.  
  81. C type PFUS = record (* unsafe reference check record *)
  82. C               TYPE: 1..5;      (* unsafe reference type *)
  83. C               ASSOC: integer;  (* punode index of calling p.u. *)
  84. C               STMTNO: integer; (* statement number of reference *)
  85. C               EXTRA: integer;  (* type-dependent extra data *)
  86. C               CALLED: integer; (* punode/exnode index of called routine *)
  87. C               ARGNUM: integer  (* argument number for unsafe check *)
  88. C             end;
  89. C---------------------------------------------------------
  90. C    TOOLPACK/1    Release: 2.5
  91. C---------------------------------------------------------
  92. C YXLIB Customisation Parameters
  93. C ------------------------------
  94.  
  95. C Routine Names
  96. C -------------
  97.  
  98. C Field Definitions: Parse Tree Attributes
  99. C ----------------------------------------
  100. C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
  101. C       NOT BE USED, as ordinary arithmetic is used to extract some fields
  102.  
  103. C Attribute Table Macros
  104. C ----------------------
  105.  
  106. C YXLIB Bits
  107. C ----------
  108.  
  109. C YXLIB Local Record Macros
  110. C -------------------------
  111. C   type VARX = record
  112. C                   su: integer;    (* Storage units for variable *)
  113. C                   common: ^(S_COMMON) or -maxint..-1;
  114. C                                   (* ^(common block symbol), nil (0) or
  115. C                                      negative of equivalence class number *)
  116. C                   comsize: integer;(* Offset in common or equiv class *)
  117. C                   equiv: ^EQV;    (* Pointer to equivalence link *)
  118. C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
  119. C                                   (* array information stored here *)
  120. C               end;
  121. C
  122. C   type ARRAYX = record
  123. C                   elts: integer;  (* Number of elements in the array *)
  124. C                   dims: integer;  (* Number of dimensions of the array *)
  125. C                   limits: array [1..dims] of
  126. C                               record LOWER,UPPER: integer end
  127. C                 end;
  128.  
  129.  
  130. C   type EQH = HEAD record          (* Equivalence head record *)
  131. C                       common: ^(S_COMMON) or -maxint..-1;
  132. C                       usage: set of usage_bits
  133. C                   end;
  134.  
  135. C   type EQV = LINK record          (* Equivalence variable record (link) *)
  136. C                       sudif: integer;
  137. C                       symbol: ^(S_VAR)
  138. C                   end;
  139.  
  140. C   type LPR = record
  141. C                   glob: ^(GPU) or -^(GEX);
  142. C                   nargs: integer;
  143. C                   args: array [1..nargs] of packed record
  144. C                               dtype: min_dtype..max_dtype;
  145. C                               argument_type: atype;
  146. C                               descendents: ^HEAD;
  147. C                               if dtype=type_char then
  148. C                                   min_length, max_length: integer
  149. C                               end if
  150. C                           end record
  151. C              end;
  152.  
  153. C                                   (* Argument type definitions *)
  154. C   type ATYPE = (scalar,arelm,array,proc,label);
  155. C   const min_atype = scalar; max_atype = label;
  156.  
  157. C YXLIB Record Definition: Semi-Local
  158. C -----------------------------------
  159. C   type PAREC = LINK record
  160. C                   argnum: integer; (* Argument number passed down as *)
  161. C                   prsym: ^(S_PROC); (* Procedure passed down to *)
  162. C                   argsym: ^symbol; (* Actual argument being passed down *)
  163. C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
  164. C                   stmtno: integer; (* Statement number of assoc (context) *)
  165. C                end;
  166.  
  167. C   type UNSAF = LINK record
  168. C                   code: 1..5;     (* Type of unsafe reference to be checked *)
  169. C                   argnum: integer;(* Argument number applicable *)
  170. C                   extra: anything;(* Extra data (not used by inherit_expr) *)
  171. C                   pusym: ^(S_PU); (* Context: associating program-unit *)
  172. C                   stmtno: integer;(* Context: statement number *)
  173. C                   prsym: ^(S_PROC)(* proc being called *)
  174. C                end;
  175.  
  176. C YXLIB Global Record Macros
  177. C --------------------------
  178. C
  179. C   type G_COM = record             Global common block record
  180. C                   size: integer;
  181. C                   type: (character,numeric,mixed); (* logical = numeric *)
  182. C                   save: (saved,not_saved,only_in_main);
  183. C                   init: integer   (* Number of times init'ed by block data *)
  184. C                end;
  185.  
  186. C
  187. C   type G_PU = record              Global program-unit record
  188. C                   dtype: integer;
  189. C                   chrlen: integer;
  190. C                   culist: ^HEAD;  (* common block usage list header ptr *)
  191. C                   nargs: integer;
  192. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  193. C                   entrys: ^(HEAD) record ^G_ENT end;
  194. C                   args: array [1..nargs] of gpuarg
  195. C               end;
  196.  
  197. C   type G_ENT = record
  198. C                   dtype: integer;
  199. C                   chrlen: integer;
  200. C                   pu: ^G_PU;
  201. C                   nargs: integer;
  202. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  203. C                   args: array [1..nargs] of ^guparg
  204. C                end;
  205.  
  206. C type gpuarg = record
  207. C                   dtype,chlen: integer;
  208. C                   usage: (arg,read,update);
  209. C                   struc: (scal,array,proc,label);
  210. C                   size: integer;
  211. C                   pass: ^HEAD;
  212. C                   inh: ^HEAD(inherit)
  213. C               end;
  214. C type inherit = record
  215. C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
  216. C                   ass: ^(GPU);    (* associating program-unit *)
  217. C                   snum: integer;  (* statement number of association *)
  218. C                   if (type=proc) then
  219. C                       gsyptr: ^(GPU)/-^(GEX)
  220. C                   else
  221. C                       extra: integer (* unsafe ref extra data *)
  222. C                   end if
  223.  
  224.  
  225. C Global Descendant Routine Types
  226. C -------------------------------
  227.  
  228. C Error Codes returned by YXLIB
  229. C -----------------------------
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238. C                                   parameter length
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246. C---------------------------------------------------------
  247. C    TOOLPACK/1    Release: 2.5
  248. C---------------------------------------------------------
  249. C ----------------------------------------------------------------------
  250. C
  251. C       P F I N I T   -   Initialise PFORT-77 Common Areas
  252. C
  253.  
  254.         SUBROUTINE PFINIT
  255.  
  256. C---------------------------------------------------------
  257. C    TOOLPACK/1    Release: 2.5
  258. C---------------------------------------------------------
  259.         COMMON/PFHEAP/USHEAD,HEAP
  260.         INTEGER USHEAD,HEAP(200000)
  261.  
  262.         SAVE /PFHEAP/
  263. C---------------------------------------------------------
  264. C    TOOLPACK/1    Release: 2.5
  265. C---------------------------------------------------------
  266.         COMMON/PFNAME/NAMTXT
  267.         COMMON/PFNAMI/NNAMES,NAMEPU
  268.         CHARACTER*6 NAMTXT(800)
  269.         INTEGER NNAMES,NAMEPU(800)
  270.         SAVE /PFNAME/,/PFNAMI/
  271. C---------------------------------------------------------
  272. C    TOOLPACK/1    Release: 2.5
  273. C---------------------------------------------------------
  274.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  275.         INTEGER NPUS,MAINND,PUNODE(500)
  276.         SAVE /PFPU/
  277. C---------------------------------------------------------
  278. C    TOOLPACK/1    Release: 2.5
  279. C---------------------------------------------------------
  280.         COMMON/PFCB/NCB,CBDATA
  281.         INTEGER NCB,CBDATA(6,250)
  282.         SAVE /PFCB/
  283. C---------------------------------------------------------
  284. C    TOOLPACK/1    Release: 2.5
  285. C---------------------------------------------------------
  286.         COMMON/PFEXTS/NEXTS,EXNODE
  287.         INTEGER NEXTS,EXNODE(500)
  288.         SAVE /PFEXTS/
  289. C---------------------------------------------------------
  290. C    TOOLPACK/1    Release: 2.5
  291. C---------------------------------------------------------
  292.         COMMON/PFWMRK/NPU,NEX
  293.         INTEGER NPU,NEX
  294.         SAVE /PFWMRK/
  295. C---------------------------------------------------------
  296. C    TOOLPACK/1    Release: 2.5
  297. C---------------------------------------------------------
  298.         COMMON/PFERRC/NPFERR,NPFWRN
  299.         INTEGER NPFERR,NPFWRN
  300.         SAVE/PFERRC/
  301.  
  302.         INTEGER LLCRHE
  303.         EXTERNAL HINIT,LLCRHE
  304.  
  305. C Initialise /PFHEAP/
  306.         CALL HINIT(HEAP,200000)
  307.         USHEAD=LLCRHE(HEAP,0)
  308. C Initialise /PFNAMI/
  309.         NNAMES=0
  310. C Initialise /PFPU/
  311.         NPUS=0
  312. C Initialise /PFCB/
  313.         NCB=0
  314. C Initialise /PFEXTS/
  315.         NEXTS=0
  316. C Initialise /PFWMRK/
  317.         NPU=0
  318.         NEX=0
  319. C Initialise /PFERRC/
  320.         NPFERR=0
  321.         NPFWRN=0
  322.  
  323.         END
  324. C ----------------------------------------------------------------------
  325. C
  326. C       P F C H K L   -   Perform local checks
  327. C                         (parse tree and symbol table)
  328. C
  329.  
  330.         SUBROUTINE PFCHKL(NERROR,NWARN)
  331.         INTEGER NERROR,NWARN
  332.  
  333. C---------------------------------------------------------
  334. C    TOOLPACK/1    Release: 2.5
  335. C---------------------------------------------------------
  336.         COMMON/PFERRC/NPFERR,NPFWRN
  337.         INTEGER NPFERR,NPFWRN
  338.         SAVE/PFERRC/
  339.  
  340.         CALL PFTREE
  341.         CALL PFSYCK
  342.  
  343.         NERROR=NPFERR
  344.         NWARN=NPFWRN
  345.  
  346.         END
  347. C ----------------------------------------------------------------------
  348. C
  349. C       P F T R E E   -   Check parse tree
  350. C
  351.  
  352.         SUBROUTINE PFTREE
  353.  
  354.         INTEGER PUPTR,PUSYM,PUNUM
  355.  
  356.         INTEGER ZYROOT,ZYDOWN,ZYNEXT,ZYGPUS
  357.         EXTERNAL ZYROOT,ZYDOWN,ZYNEXT,ZYGPUS
  358.  
  359.         PUPTR=ZYDOWN(ZYROOT())
  360.         PUNUM=1
  361.  
  362.  100    PUSYM=ZYGPUS(PUNUM)
  363.         CALL PFPUCK(PUPTR,PUSYM)
  364.         PUPTR=ZYNEXT(PUPTR)
  365.         PUNUM=PUNUM+1
  366.         IF (PUPTR.NE.0) GOTO 100
  367.  
  368.         END
  369. C ----------------------------------------------------------------------
  370. C
  371. C       P F S Y C K   -   Symbol table check
  372. C
  373.  
  374.         SUBROUTINE PFSYCK
  375.  
  376.         INTEGER SYMBOL(8),SYMPTR,COMPTR,VARPTR,DTYPE,
  377.      +          TEXT(134),BLNKCM(8),MAINPR(6)
  378.         LOGICAL LEGAL,LOCLEG
  379.  
  380.         INTEGER ZYGNSY,ZIAND,ZYXGVA,ZYFDUP,EQUAL
  381.         EXTERNAL ZYGNSY,ZIAND,ZYXGVA,ZYXGCV,ZYGTSY,ZYFDUP,
  382.      +           ZYGTST,ZLEGAL,EQUAL
  383.  
  384.         DATA BLNKCM/36,67,79,77,77,79,78,129/,
  385.      +       MAINPR/36,77,65,73,78,129/
  386.  
  387.         SYMPTR=0
  388.  
  389.  100    IF (ZYGNSY(SYMPTR,SYMBOL).NE.-100) THEN
  390.             IF (SYMBOL(1).NE.1) THEN
  391.                 CALL ZYGTST(SYMBOL(2),TEXT)
  392.                 CALL ZLEGAL(TEXT,LEGAL,LOCLEG)
  393.                 IF (.NOT.LEGAL)
  394.      +              LEGAL=EQUAL(TEXT,BLNKCM).EQ.-2 .OR.
  395.      +                    EQUAL(TEXT,MAINPR).EQ.-2
  396.                 IF (.NOT.LEGAL)
  397.      +              CALL PFERR('E: Illegal name in $P - $S',
  398.      +                         SYMBOL(3),SYMPTR,0,0)
  399.             END IF
  400.             IF (SYMBOL(1).GE.3) THEN
  401.                 IF (SYMBOL(4).EQ.6) THEN
  402.                     IF (SYMBOL(5).GT.255) THEN
  403.                         CALL PFERR(
  404.      +'E: Character variable $S too long in $P',
  405.      +                             SYMPTR,SYMBOL(3),0,0)
  406.                     ELSE IF (SYMBOL(5).LT.0) THEN
  407.                         IF (ZYXGVA(-SYMBOL(5)).GT.255)
  408.      +                      CALL PFERR(
  409.      +'E: Character variable $S too long in $P',SYMPTR,
  410.      +SYMBOL(3),0,0)
  411.                     END IF
  412.                 ELSE IF (SYMBOL(5).NE.0) THEN
  413.                     CALL PFERR('E: Invalid data type for $S in $P',
  414.      +                         SYMPTR,SYMBOL(3),0,0)
  415.                 ELSE IF (SYMBOL(4).EQ.7) THEN
  416.                     CALL PFERR('E: $S is DOUBLE COMPLEX in $P',
  417.      +                         SYMPTR,SYMBOL(3),0,0)
  418.                 END IF
  419.                 IF (ZIAND(SYMBOL(6),
  420.      +                    2048+4096+2).EQ.
  421.      +              2048+4096) THEN
  422.                     CALL PFERR('E: Intrinsic $S passed as arg but n'//
  423.      +                         'ot declared as INTRINSIC in $P',
  424.      +                         SYMPTR,SYMBOL(3),0,0)
  425.                 ELSE IF (ZIAND(SYMBOL(6),
  426.      +                         4096+8).EQ.
  427.      +                         4096+8) THEN
  428.                     CALL PFERR(
  429.      +'E: Standard intrinsic $S explicitly typed in $P',
  430.      +                         SYMPTR,SYMBOL(3),0,0)
  431.                 ELSE IF (SYMBOL(1).EQ.7 .AND.
  432.      +                   ZIAND(SYMBOL(6),4096+
  433.      +                                             2+
  434.      +                                             1).EQ.0)
  435.      +          THEN
  436.                     CALL PFERR('W: External reference $S n'//
  437.      +                         'ot declared as EXTERNAL in $P',
  438.      +                         SYMPTR,SYMBOL(3),0,0)
  439.                 ELSE IF (SYMBOL(1).EQ.7 .AND.
  440.      +                   SYMBOL(4).NE.-1 .AND.
  441.      +                   ZIAND(SYMBOL(6),8+
  442.      +                                             2+
  443.      +                                             4096).EQ.0)
  444.      +          THEN
  445.                     CALL PFERR(
  446.      +'E: External function $S implicitly typed in $P',
  447.      +                         SYMPTR,SYMBOL(3),0,0)
  448.                 ELSE IF (ZIAND(SYMBOL(6),65536).NE.0)
  449.      +          THEN
  450.                     IF (SYMBOL(4).NE.1)
  451.      +                  CALL PFERR('E: DO-loop index $S n'//
  452.      +                             'ot INTEGER in $P',
  453.      +                             SYMPTR,SYMBOL(3),0,0)
  454.                     IF (SYMBOL(1).EQ.4)
  455.      +                  CALL PFERR('E: Program-unit name $S used as '//
  456.      +                             'DO loop index',SYMPTR,0,0,0)
  457.                 END IF
  458.                 IF (ZIAND(SYMBOL(6),4).NE.0) THEN
  459.                     IF (ZIAND(SYMBOL(6),16).NE.0) THEN
  460.                         CALL PFERR(
  461.      +'E: Dummy argument $S used in ASSIGN in $P',
  462.      +                             SYMPTR,SYMBOL(3),0,0)
  463.                     ELSE IF (ZIAND(SYMBOL(6),256).NE.0)
  464.      +              THEN
  465.                         CALL PFERR(
  466.      +'E: Dummy argument $S is a statement function dummy in $P',
  467.      +                             SYMPTR,SYMBOL(3),0,0)
  468.                     END IF
  469.                 ELSE IF (ZIAND(SYMBOL(6),256).NE.0)
  470.      +          THEN
  471.                     IF (ZIAND(SYMBOL(6),16).NE.0)
  472.      +                  CALL PFERR(
  473.      +'E: Stmt fn dummy argument $S used in ASSIGN in $P',
  474.      +                             SYMPTR,SYMBOL(3),0,0)
  475.                 END IF
  476.                 IF (ZIAND(SYMBOL(6),1048576).NE.0) THEN
  477.                     IF (ZIAND(SYMBOL(6),
  478.      +                        32+64+16).NE.0)
  479.      +                  CALL PFERR(
  480.      +'W: $S is used in an array declarator but is updated in $P',
  481.      +                      SYMPTR,SYMBOL(3),0,0)
  482.                 END IF
  483.                 CALL PFCHKU(SYMBOL,SYMPTR)
  484.             ELSE IF (SYMBOL(1).EQ.2) THEN
  485.                 COMPTR=SYMPTR
  486.                 DTYPE=4
  487.  200            CALL ZYXGCV(COMPTR,VARPTR)
  488.                 CALL ZYGTSY(VARPTR,SYMBOL)
  489.                 IF ((SYMBOL(4).EQ.4 .OR.
  490.      +              SYMBOL(4).EQ.5) .AND.
  491.      +              DTYPE.NE.4 .AND. DTYPE.NE.5)
  492.      +          THEN
  493.                     CALL PFERR(
  494.      +'E: COMPLEX o'//'r DOUBLE PRECISION n'//'ot first in COMMON /'//
  495.      +'$S/ in $P',SYMPTR,SYMBOL(3),0,0)
  496.                     GOTO 100
  497.                 END IF
  498.                 DTYPE=SYMBOL(4)
  499.                 IF (COMPTR.NE.0) GOTO 200
  500.                 VARPTR=ZYFDUP(SYMPTR)
  501.                 IF (VARPTR.GT.0) THEN
  502.                     CALL ZYGTSY(VARPTR,SYMBOL)
  503.                     IF (SYMBOL(1).EQ.8) THEN
  504.                         CALL PFERR(
  505.      +'E: $S names both COMMON a'//'nd a statement function in $P',
  506.      +                             SYMPTR,SYMBOL(3),0,0)
  507.                     ELSE IF (SYMBOL(1).EQ.6) THEN
  508.                         CALL PFERR(
  509.      +'E: $S names both COMMON a'//'nd a PARAMETER in $P',
  510.      +                             SYMPTR,SYMBOL(3),0,0)
  511.                     ELSE IF (ZIAND(SYMBOL(6),16).NE.0)
  512.      +              THEN
  513.                         CALL PFERR(
  514.      +'E: $S names both COMMON a'//'nd an ASSIGN variable in $P',
  515.      +                             SYMPTR,SYMBOL(3),0,0)
  516.                     ELSE IF (ZIAND(SYMBOL(6),4).NE.0)
  517.      +              THEN
  518.                         CALL PFERR(
  519.      +'E: $S names both COMMON a'//'nd a dummy argument in $P',
  520.      +                             SYMPTR,SYMBOL(3),0,0)
  521.                     ELSE IF (ZIAND(SYMBOL(6),256).NE.0)
  522.      +              THEN
  523.                         CALL PFERR(
  524.      +'E: $S names both COMMON a'//'nd a stmt fn dummy in $P',
  525.      +                             SYMPTR,SYMBOL(3),0,0)
  526.                     END IF
  527.                 END IF
  528.             END IF
  529.             GOTO 100
  530.         END IF
  531.  
  532.         END
  533. C ----------------------------------------------------------------------
  534. C
  535. C       P F C H K U   -   Check symbol usage
  536. C
  537.  
  538.         SUBROUTINE PFCHKU(SYMBOL,SYMPTR)
  539.         INTEGER SYMBOL(8),SYMPTR
  540.  
  541.         INTEGER SET,REF,NONLOC
  542.         PARAMETER (SET=16+32+64+128+
  543.      +                 65536+131072)
  544.         PARAMETER (REF=2048+16384+65536)
  545.         PARAMETER (NONLOC=4+256+1024+
  546.      +                    524288)
  547.  
  548.         INTEGER PTR,RESULT(8),VARPTR,EQHCOM,EQHUSE,EQVPTR,TMP
  549.  
  550.         INTEGER ZIAND,ZYGNSW,ZIOR
  551.         LOGICAL ZYXVOL
  552.         EXTERNAL ZIAND,ZYGNSW,ZYXGEH,ZYGTSY,ZYXVOL,ZIOR
  553.  
  554.         IF (SYMBOL(1).EQ.3) THEN
  555.             IF (ZIAND(SYMBOL(6),4).NE.0) THEN
  556.                 CALL PFERR('W: Unused dummy argument: $S in $P',
  557.      +                     SYMPTR,SYMBOL(3),0,0)
  558.             ELSE
  559.                 CALL PFERR('W: Unused symbol: $S in $P',
  560.      +                     SYMPTR,SYMBOL(3),0,0)
  561.             END IF
  562.         ELSE IF (SYMBOL(1).EQ.5 .AND.
  563.      +           ZIAND(SYMBOL(6),NONLOC).EQ.0) THEN
  564.             IF (ZIAND(SYMBOL(6),125936).EQ.0) THEN
  565.                 CALL PFERR('W: Unused variable: $S in $P',
  566.      +                     SYMPTR,SYMBOL(3),0,0)
  567.             ELSE IF (ZIAND(SYMBOL(6),SET).EQ.0 .NEQV.
  568.      +               ZIAND(SYMBOL(6),REF).EQ.0) THEN
  569.                 IF (ZIAND(SYMBOL(6),512).NE.0) THEN
  570.                     IF (SYMBOL(4).EQ.4)
  571.      +                  SYMBOL(4)=2
  572.                     IF (SYMBOL(4).EQ.7)
  573.      +                  SYMBOL(4)=5
  574.                     CALL ZYXGEH(SYMPTR,EQHCOM,EQHUSE,EQVPTR)
  575.   50                CALL ZYXGED(EQVPTR,VARPTR,TMP)
  576.                     IF (SYMPTR.NE.VARPTR .AND.
  577.      +                  ZYXVOL(SYMPTR,VARPTR)) THEN
  578.                         CALL ZYGTSY(VARPTR,RESULT)
  579.                         IF (SYMBOL(4).EQ.RESULT(4)
  580.      +                      .OR. RESULT(4).EQ.4
  581.      +                      .AND. SYMBOL(4).EQ.2
  582.      +                      .OR. RESULT(4).EQ.7
  583.      +                      .AND. SYMBOL(4).EQ.5)
  584.      +                      SYMBOL(6)=
  585.      +                          ZIOR(SYMBOL(6),
  586.      +                               RESULT(6))
  587.                     END IF
  588.                     IF (EQVPTR.NE.0) GOTO 50
  589.                 END IF
  590.                 IF (ZIAND(SYMBOL(6),SET).EQ.0 .NEQV.
  591.      +              ZIAND(SYMBOL(6),REF).EQ.0) THEN
  592.                     IF (ZIAND(SYMBOL(6),SET).EQ.0) THEN
  593.                         CALL PFERR(
  594.      +'E: Variable referenced but n'//'ot set - $S in $P',
  595.      +                             SYMPTR,SYMBOL(3),0,0)
  596.                     ELSE
  597.                         CALL PFERR(
  598.      +'W: Variable set but n'//'ot referenced - $S in $P',
  599.      +                             SYMPTR,SYMBOL(3),0,0)
  600.                     END IF
  601.                 END IF
  602.             END IF
  603.         ELSE IF (SYMBOL(1).EQ.4 .AND.
  604.      +           SYMBOL(4).GT.0 .AND.
  605.      +           ZIAND(SYMBOL(6),SET).EQ.0) THEN
  606.             PTR=SYMPTR
  607.  100        IF (ZYGNSW(PTR,SYMBOL(3),RESULT).EQ.-2) THEN
  608.                 IF (RESULT(1).NE.9) THEN
  609.                     GOTO 100
  610.                 ELSE IF (ZIAND(RESULT(6),SET).EQ.0) THEN
  611.                     GOTO 100
  612.                 END IF
  613.             ELSE
  614.                 CALL PFERR('E: Function value n'//'ot set - $S',
  615.      +                     SYMPTR,0,0,0)
  616.             END IF
  617.         END IF
  618.  
  619.         END
  620. C ----------------------------------------------------------------------
  621. C
  622. C       P F P U C K   -   Check a program-unit's parse tree
  623. C
  624.  
  625.         SUBROUTINE PFPUCK(PUROOT,PUSYM)
  626.         INTEGER PUROOT,PUSYM
  627.  
  628.         INTEGER SPTR,STMTNO
  629.  
  630.         INTEGER ZYDOWN,ZYNEXT
  631.         EXTERNAL ZYDOWN,ZYNEXT
  632.  
  633.         SPTR=ZYDOWN(PUROOT)
  634.         STMTNO=1
  635.  
  636.  100    CALL PFSTCK(SPTR,STMTNO,PUSYM)
  637.         SPTR=ZYNEXT(SPTR)
  638.         STMTNO=STMTNO+1
  639.         IF (SPTR.NE.0) GOTO 100
  640.  
  641.         END
  642. C ----------------------------------------------------------------------
  643. C
  644. C       P F S T C K   -   Check the parse tree of a statement
  645. C
  646.  
  647.         SUBROUTINE PFSTCK(SPTR,STMTNO,PUSYM)
  648.         INTEGER SPTR,STMTNO,PUSYM
  649.  
  650.         INTEGER PTR,NEXT,STYPE,DOVAR
  651.  
  652.         INTEGER ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,ZYXGTB,ZIAND
  653.         EXTERNAL ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,ZYXGTB,ZIAND
  654.  
  655.         STYPE=ZYNTYP(SPTR)
  656.         IF (STYPE.EQ.64) THEN
  657.             CALL PFERR('E: PAUSE statement found, statement $I in $S',
  658.      +                 STMTNO,PUSYM,0,0)
  659.         ELSE IF (STYPE.EQ.75) THEN
  660.             CALL PFERR(
  661.      +'W: The BACKSPACE statement is non-portable, statement $I in $S',
  662.      +                 STMTNO,PUSYM,0,0)
  663.         ELSE IF (STYPE.EQ.76) THEN
  664.             CALL PFERR(
  665.      +'W: The ENDFILE statement is non-portable, statement $I in $S',
  666.      +                 STMTNO,PUSYM,0,0)
  667.         ELSE IF (STYPE.EQ.61) THEN
  668.             DOVAR=0
  669.         ELSE IF (STYPE.EQ.41) THEN
  670.             IF (ZIAND(ZYXGTB(SPTR),16777216).NE.0)
  671.      +          CALL PFERR(
  672.      +'E: Type conversion in DATA at statement $I in $S',
  673.      +                     STMTNO,PUSYM,0,0)
  674.         END IF
  675.         PTR=ZYDOWN(SPTR)
  676.         IF (PTR.EQ.0) RETURN
  677.  
  678.  100    CONTINUE
  679. C Visit node PTR
  680.         CALL PFVNOD(PTR,STYPE,STMTNO,PUSYM,DOVAR)
  681. C Go down from PTR
  682.         NEXT=ZYDOWN(PTR)
  683.         IF (NEXT.GT.0) THEN
  684.             PTR=NEXT
  685.             GOTO 100
  686.         END IF
  687. C At a leaf - go next
  688.  200    NEXT=ZYNEXT(PTR)
  689.         IF (NEXT.EQ.0) THEN
  690.             PTR=ZYUP(PTR)
  691.             IF (PTR.NE.SPTR) GOTO 200
  692.         END IF
  693.         IF (NEXT.NE.0) THEN
  694.             PTR=NEXT
  695.             GOTO 100
  696.         END IF
  697.  
  698.         END
  699. C ----------------------------------------------------------------------
  700. C
  701. C       P F V N O D   -   Visit a node in the parse tree
  702. C
  703.  
  704.         SUBROUTINE PFVNOD(NODE,STYPE,STMTNO,PUSYM,DOVAR)
  705.         INTEGER NODE,STYPE,STMTNO,PUSYM,DOVAR
  706.  
  707.         INTEGER MAXCSW
  708.         PARAMETER (MAXCSW=10)
  709.  
  710.         INTEGER NTYPE,TEXT(134),I,PTR,SYMBOL(8),DTYPE,NCSW
  711.         CHARACTER C
  712.         LOGICAL WARNED,MIXEDT
  713.  
  714.         CHARACTER ZCITOC
  715.         INTEGER ZYNTYP,ZYDOWN,ZYXGDT,ZYXGVA,ZYNEXT,ZYXEAE,
  716.      +          ZYUP,ZIAND,ZYXGTB
  717.         EXTERNAL ZYNTYP,ZYDOWN,ZYXGDT,ZYXGVA,ZYGTST,ZCITOC,ZYNEXT,
  718.      +           ZYUP,ZYGTSY,ZYXEAE,ZIAND,ZYXGTB,ZYSABT
  719.  
  720.         DATA NCSW/0/
  721.  
  722.         NTYPE=ZYNTYP(NODE)
  723.         IF (NTYPE.EQ.113 .AND. STYPE.NE.78) THEN
  724.             CALL PFERR(
  725.      +          'E: Hollerith constant found at statement $I in $S',
  726.      +          STMTNO,PUSYM,0,0)
  727.  
  728.         ELSE IF (NTYPE.EQ.102) THEN
  729.             IF (ZYXGDT(NODE).EQ.7)
  730.      +          CALL PFERR(
  731.      +'E: Double Complex constant found at statement $I in $S',
  732.      +                     STMTNO,PUSYM,0,0)
  733.  
  734.         ELSE IF (NTYPE.EQ.114 .OR. NTYPE.EQ.113) THEN
  735.             IF (ZYXGVA(NODE).GT.64) THEN
  736.                 CALL PFERR(
  737.      +'E: Character constant too long at statement $I in $S',
  738.      +                     STMTNO,PUSYM,0,0)
  739.             ELSE IF (NCSW.LT.MAXCSW) THEN
  740.                 CALL ZYGTST(-ZYDOWN(NODE),TEXT)
  741.                 WARNED=.FALSE.
  742.                 DO 100 I=1,ZYXGVA(NODE)
  743.                     IF (TEXT(I).EQ.36 .AND..NOT.WARNED) THEN
  744.                         NCSW=NCSW+1
  745.                         CALL PFERR(
  746.      +'W: Currency symbol in character constant at statement $I in $S',
  747.      +                             STMTNO,PUSYM,0,0)
  748.                         IF (NCSW.EQ.MAXCSW) THEN
  749.                             CALL PFERR(
  750.      +'W: Further character set warnings will be suppressed',
  751.      +                                 0,0,0,0)
  752.                             RETURN
  753.                         END IF
  754.                         WARNED=.TRUE.
  755.                     ELSE IF (INDEX(
  756.      +' ETOANIRSHBCDFGJKLMPQUVWXYZ0123456789*()-=+'':/.,$',
  757.      +                        ZCITOC(TEXT(I),C)).EQ.0) THEN
  758.                         NCSW=NCSW+1
  759.                         CALL PFERR('W: Non-standard character '''//C//
  760.      +''' in character constant at statement $I in $S',
  761.      +                             STMTNO,PUSYM,0,0)
  762.                         IF (NCSW.EQ.MAXCSW) CALL PFERR(
  763.      +'W: Further character set warnings will be suppressed',
  764.      +                                                 0,0,0,0)
  765.                         RETURN
  766.                     END IF
  767.  100            CONTINUE
  768.             END IF
  769.         ELSE IF (NTYPE.EQ.95 .OR. NTYPE.EQ.96 .OR.
  770.      +           NTYPE.EQ.98 .OR. NTYPE.EQ.99 .OR.
  771.      +           NTYPE.EQ.100) THEN
  772.             IF (ZYXGDT(NODE).EQ.7) CALL PFERR(
  773.      +'E: Double complex operation at statement $I in $S',
  774.      +          STMTNO,PUSYM,0,0)
  775.         ELSE IF (NTYPE.EQ.112) THEN
  776.             CALL ZYGTST(-ZYDOWN(NODE),TEXT)
  777.             IF ((TEXT(1).EQ.84 .OR. TEXT(1).EQ.116) .AND.
  778.      +          (TEXT(2).EQ.76 .OR. TEXT(2).EQ.108 .OR.
  779.      +          TEXT(2).GE.48 .AND. TEXT(2).LE.57))
  780.      +          CALL PFERR(
  781.      +'E: T o'//'r TL edit descriptor at statement $I in $S',
  782.      +                     STMTNO,PUSYM,0,0)
  783.         ELSE IF (NTYPE.EQ.54 .AND. STYPE.EQ.53) THEN
  784.             CALL PFERR(
  785.      +'E: Label list supplied in assigned GOTO at statement $I in $S',
  786.      +                 STMTNO,PUSYM,0,0)
  787.         ELSE IF (NTYPE.EQ.108 .AND. STYPE.EQ.61) THEN
  788.             IF (DOVAR.EQ.0) THEN
  789.                 IF (ZYNTYP(ZYUP(NODE)).NE.48 .OR.
  790.      +              ZYDOWN(ZYUP(NODE)).NE.NODE) THEN
  791.                     CALL PFERR(
  792.      +'I: Apparently badly formed DOSPEC subtree at node $I',
  793.      +                         NODE,0,0,0)
  794.                 ELSE
  795.                     DOVAR=ZYDOWN(NODE)
  796.                 END IF
  797.             ELSE IF (ZYDOWN(NODE).EQ.DOVAR) THEN
  798.                 IF (ZYNTYP(ZYUP(NODE)).NE.48 .OR.
  799.      +              ZYDOWN(ZYUP(NODE)).NE.NODE)
  800.      +              CALL PFERR(
  801.      +'E: DO variable used in limit expression at statement $I in $S',
  802.      +                         STMTNO,PUSYM,0,0)
  803.             END IF
  804.         ELSE IF (NTYPE.EQ.108 .AND. STYPE.EQ.30) THEN
  805.             NTYPE=ZYNTYP(ZYUP(NODE))
  806.             IF (NTYPE.EQ.30 .OR. NTYPE.EQ.31) THEN
  807.                 CALL ZYSABT(-ZYDOWN(NODE),6,4194304)
  808.             ELSE
  809.                 CALL ZYGTSY(-ZYDOWN(NODE),SYMBOL)
  810.                 IF (SYMBOL(7).EQ.0 .AND.
  811.      +              ZIAND(SYMBOL(6),
  812.      +                    4194304+8).EQ.8)
  813.      +              CALL PFERR(
  814.      +'E: $S used in array declarator before type declaration, at '//
  815.      +'statement $I in $S',-ZYDOWN(NODE),STMTNO,PUSYM,0)
  816.             END IF
  817.         ELSE IF (NTYPE.EQ.25) THEN
  818.             PTR=ZYDOWN(NODE)
  819.             MIXEDT=.FALSE.
  820.             DTYPE=ZYXGDT(PTR)
  821.  200        PTR=ZYNEXT(PTR)
  822.             IF (PTR.NE.0) THEN
  823.                 IF (ZYXGDT(PTR).EQ.DTYPE) GOTO 200
  824.                 MIXEDT=.TRUE.
  825.             END IF
  826.             IF (MIXEDT) THEN
  827.                 PTR=ZYDOWN(NODE)
  828.  300            NTYPE=ZYNTYP(PTR)
  829.                 IF (NTYPE.EQ.104) THEN
  830.                     IF (ZYXEAE(PTR).NE.0) THEN
  831.                         CALL PFERR(
  832.      +'E: Equivalence of non-initial array element involving differin'//
  833.      +'g data types',0,0,0,0)
  834.                         CALL PFERR(
  835.      +' array $S at statement $I in $S',-ZYDOWN(ZYDOWN(PTR)),
  836.      +                             STMTNO,PUSYM,0)
  837.                     END IF
  838.                 ELSE IF (NTYPE.EQ.103) THEN
  839.                     I=ZYDOWN(PTR)
  840.                     IF (ZYNTYP(I).EQ.104) THEN
  841.                         IF (ZYXEAE(I).NE.0) THEN
  842.                             CALL PFERR(
  843.      +'E: Equivalence of non-initial array element involving differin'//
  844.      +'g data types',0,0,0,0)
  845.                             CALL PFERR(
  846.      +' array $S at statement $I in $S',-ZYDOWN(ZYDOWN(I)),
  847.      +                             STMTNO,PUSYM,0)
  848.                         END IF
  849.                     END IF
  850.                 END IF
  851.                 PTR=ZYNEXT(PTR)
  852.                 IF (PTR.NE.0) GOTO 300
  853.             END IF
  854.         ELSE IF (NTYPE.EQ.89 .OR. NTYPE.EQ.90 .OR.
  855.      +           NTYPE.EQ.93 .OR. NTYPE.EQ.94) THEN
  856.             IF (ZYXGDT(ZYDOWN(NODE)).EQ.6)
  857.      +          CALL PFERR(
  858.      +'E: Relational operator used with character operands at '//
  859.      +                     'statement $I in $S',STMTNO,PUSYM,0,0)
  860.         ELSE IF (NTYPE.EQ.123) THEN
  861.             PTR=ZYDOWN(NODE)
  862.             IF (ZIAND(ZYXGTB(PTR),4194304).NE.0) THEN
  863.                 IF (ZYXGDT(PTR).NE.6)
  864.      +              CALL PFERR(
  865.      +'E: Invalid type of array used for format-identifier at '//
  866.      +                         'statement $I in $S',STMTNO,PUSYM,0,0)
  867.             END IF
  868.         END IF
  869.  
  870.         END
  871.